COMMENT ⊗   VALID 00008 PAGES VERSION 17-1(21)
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	HISTORY
 00005 00003	Array Stuff 
 00012 00004	  bexit & stkuwd  
 00022 00005	 array info & the like 
 00027 00006	 the procedure item routines
 00031 00007	
 00039 00008	
 00043 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000025  ⊗;


COMMENT ⊗
VERSION 17-1(21) 11-30-74 BY RHT BUG #TS# ARRCLR WAS LOSING FOR 1 WORD ARRAYS
VERSION 17-1(20) 9-27-74 BY JFR INSTALL BAIL (MODIFY APPLY)
VERSION 17-1(19) 6-6-74 BY RHT BUG #SO# CLOBBERING B IN PARLP
VERSION 17-1(18) 5-27-74 BY RHT ADD FACILITY FOR RECORD ARRAYS IN BEXIT
VERSION 17-1(17) 5-19-74 
VERSION 17-1(16) 4-14-74 BY RHT %BI% ADD RECORDS TO BEXIT
VERSION 17-1(15) 4-14-74 
VERSION 17-1(14) 3-6-74 BY RHT ADD LEAP TO EXTERNS FOR SAIPIT
VERSION 17-1(13) 2-24-74 BY RHT FEAT %BH% -- TEMP REF ITEMS
VERSION 17-1(12) 2-3-74 BY RHT BUG #QZ# APPLY TESTING WRONG FIELD FOR STRING VAL PARAM
VERSION 17-1(11) 1-29-74 BY RHT BUG #QW# APPLY TOO TOUGH ON UNTYP ITEMVAR ACTUALS
VERSION 17-1(10) 1-28-74 BY RHT BUG #QU# TYPO IN APPLY
VERSION 17-1(9) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(8) 12-4-73 BY RHT MAKE ARRCL HAVE A DEFAULT VALUE TO STORE
VERSION 17-1(7) 12-2-73 BY RLS EDIT
VERSION 17-1(6) 12-2-73 BY RLS EDIT
VERSION 17-1(5) 12-1-73 BY RLS BUG #PL#  DONT BLT IF LENGTH LEQ 0; PLUS ADD ARRCLR FUNCTION
VERSION 17-1(4) 11-20-73 BY RFS   
VERSION 17-1(3) 11-20-73 BY rfs MAKE LOWER BOUND > UPPER BOUND CONTINUABLE
VERSION 17-1(2) 10-14-73 BY RHT BUG #OP#
VERSION 17-1(1) 10-14-73 BY RHT BUG #OL#-- TYPO IN APPLY
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 **** **** VERSION 17-1(0)
VERSION 16(4) 7-24-73 BY RHT BUG #NG# SIMPLE PROC GO TO NS PROC SHOULD SORT OF WORK
VERSION 16(3) 7-24-73 BY RHT BUG #NF# -- FOUND TBITS USE LURKING IN STKUWD
VERSION 16(2) 7-14-73 BY RHT ADD APPLY$
VERSION 16(1) 7-13-73 BY RHT MAKE APPLY RETURN A VALUE LIKE IT IS SUPPOSED TO

⊗;
COMMENT ⊗Array Stuff ⊗

;ARYDIR, ARRPDL, AND FRIENDS ARE NO MORE

DSCR LRCOP, ARCOP
⊗

COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN,ARRCLR>>
  ,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
  ,<ARRAY ALLOCATION ROUTINES>)

HERE(LRCOP)
HERE(ARCOP)
;;#HO# 6-7-72 DCS ALLOW BOTH ADDRS TO BE RETURNED
	PUSH	P,B
	PUSH	P,C		;SOME WORK SPACE.
	PUSH	P,-3(P)		;ARRAY TO BE COPIED
	PUSHJ	P,..ARCOP	;COPY IT
	POP	P,C
	POP	P,B
	SUB	P,X22
	JRST	@2(P)		;DONE

↑↑..ARCOP:
;;#HO#
	HRRZ	A,-1(P)		;THE ARRAY TO BE COPIED.
	SKIPGE	-2(A)
	SUBI	A,1		;FOR STRING ARRAYS.
	HLRE	B,-1(A)		;NUMBER OF DIMENSIONS.
	MOVMS	B		;ABSOLUTE VALUE.
	IMUL	B,[-3]
	ADDI	A,-2(B)		;A NOW POINTS TO "CORGET" GUY.
	MOVN	C,-1(A)		;SIZE
	SUBI	C,3		;TO ACCOUNT FOR BOOKEEPING.
	PUSHJ	P,CORGET
	ERR	<NO ROOM FOR ARRAY>
	PUSH	P,B
	HRLI	B,(A)		;MAKE UP A BLT WORD.
	ADDI	C,(B)
	BLT	B,-1(C)		;COPY THE WHOLE ARRAY.
	POP	P,B		;BECAUSE BLT DESTROYS ITS.
	HRRZS	A		;SINCE THE ADDI ABOVE LEFT STUFF IN LEFT HALF.
	MOVNS	A
	ADDI	A,(B)		;A HAS NEW-OLD DIFFERENCE.
	ADDM	A,(B)		;THESE HAVE TO BE RELOCATED.
	ADD	A,-1(P)		;NEW ARRAY DESCRIPTOR.
	HRRM	A,-2(B)		;FOR STRING GARBAGE COLLECTOR.
	MOVE	C,-1(P)		;ARRAY THAT WAS COPIED.
	SKIPGE	-2(C)		;WAS IT A STRING ARRAY?
	SOS	-2(B)		;BACK IT UP ONCE.
	SUB	P,X22
	JRST	@2(P)		;ALL DONE.

DSCR LRMAK
⊗
HERE(LRMAK)
DSCR ARMAK
⊗

HERE (ARMAK)
BEGIN	ARMAK
	PUSHJ	P,SAVE
	HRRZ	A,-1(P)		;#DIMENSIONS
	MOVEI	B,-2(P)		; PTR TO BOUNDS(n)
	MOVEI	C,1

MAKLUP:	SOJL	A,SIZDUN	;DONE GETTING TOTAL SIZE
	MOVE	D,(B)		;UPPER BOUND
	ADDI	D,1		;PLUS ONE.
	SUB	D,-1(B)		;  -LOWER BOUND IS TOTAL SIZE
	SKIPG	D		;MUST BE POSITIVE
	 ERR	 <ARRAY lower bound gtr  upper bound>,1,SIZ0
	IMUL	C,D		;COLLECT SIZE
SIZ0:	SUBI	B,2		;LOOK AT NEXT
	JRST	MAKLUP

SIZDUN:	; MOVEI C,SIZE DESIRED -- ALREADY THERE
	SKIPGE	-1(P)		;IF #DIMS POSITIVE, THEN NOT STRING ARRAY
	LSH	C,1		;MULTIPLY BY TWO FOR STRINGS.
	PUSH	P,C		;SAVE SIZE OF ARRAY ITSELF
	HRRZ	A,-2(P)		;#DIMENSIONS AGAIN
	IMULI	A,3		;SIZE OF ARRAY DESCRIPTOR TABLE
	ADDI	C,2(A)		;ADD TO SIZE OF AREA NEEDED
AGIN:	PUSH	P,C		;SAVE IT
	PUSHJ	P,CORGET		;ARRAY
	 ERR	 <ARRAY no room>

GOTARR:	POP	P,C		;TOTAL SIZE AGAIN
	MOVE	D,B		;SAVE ADDRESS
	HRRZ	TEMP,B
	ADD	TEMP,C
	POP	P,C		;ARRAY SIZE
	PUSH	P,B		;SAVE PTR TO ARRAY BLOCK
	SETZM	(B)
	HRLS	B
	ADDI	B,1
	BLT	B,-1(TEMP)	;CLEAR ARRAY
	HRRZI	B,(D)		;GET ADDRESS BACK
	HRRZ	TEMP,-2(P)	;#DIMENSIONS AGAIN
	SKIPGE	-2(P)		;STRING ARRAY?
	 MOVNS	TEMP		; YES
	HRL	C,TEMP		;#DIMS, TOTAL SIZE (#DIMS NEG IF STRING)
	PUSH	P,C		;SAVE INFORMATION WORD


COMMENT ⊗
LET D PNT TO NEXT WORD INTO TABLE,  A=COUNT OF DIMENSIONS LEFT,
    C=ACCUMULATING TOTAL SIZES (AGAIN)
    B PNTS AT CURRENT DESCRIPTIONS (IN STACK),  TEMP USED FOR MOVING THINGS
⊗

	ADDI	B,1		;LEAVE ROOM FOR ADDRESS WORD
	HRRZ	A,-3(P)		;#DIMS
	MOVE	LPSA,A		;PREPARE FOR SUBRT RETURN
	LSH	LPSA,1
	ADDI	LPSA,2
	HRLS	LPSA
	MOVEI	D,-4(P)		; PTR TO INFO
	;MOVE	D,[FIRST WORD]	;ALREADY THERE
	MOVEI	C,1		;MULTIPLY FACTOR
	MOVEI	X,0		;ACCUMULATE TOTAL DISPLACEMENT

STOLUP:	SOJL	A,STODUN
	MOVEW	(<1(B)>,<(D)>) ;UPPER BOUND
	ADDI	TEMP,1
	SUB	TEMP,-1(D)		;TOTAL SIZE
	MOVEM	C,2(B)		;AND MULTIPLY FACTOR
	IMUL	C,TEMP		;TEMP HAS SIZE THIS DIMENSION
	MOVEW	(<(B)>,<-1(D)>)	;STORE LOWER BOUND
	IMUL	TEMP,2(B)	;COLLECT TOTAL DISPLACEMENT
	ADD	X,TEMP		;IN X
	ADDI	B,3
	SUBI	D,2
	JRST	STOLUP		;UPDATE POINTERS AND LOOP


STODUN:	POP	P,(B)		;INFO WORD
	ADDI	B,1		;WILL POINT AT FIRST DATA WORD
	POP	P,TEMP	;PTR TO BLOCK HEAD
	HRRZM	B,-2(TEMP)	;STORE WHERE STRNGC CAN FIND IT
	SKIPGE	-1(B)		;IS IT A STRING ARRAY?
	HRROI	B,1(B)		;YES, POINT AT 2D WORD OF FIRST ELEMENT
	MOVEM	B,RACS+1(USER)	;RESULT
	JUMPGE	B,NSTG		;STRING ARRAY?
	 LSH	 X,1		; YES, DOUBLE DISPLACEMENT
NSTG:	SUB	B,X		;ARRAY ADDR - TOTAL DISPLACEMENT
	HLL	B,RACS+1(USER)	;-1 IF STRING, 0 OTHERWISE
	MOVEM	B,(TEMP)	;SAVE IN (0,0,0) WORD
	JRST	RESTR



BEND ARMAK


DSCR ARYEL
⊗

HERE(ARYEL)
BEGIN ARYEL
	HRRZ	B,-1(P)
	POP	P,-1(P)		;PUT POPJ ADDRESS BACK FOR CORREL.
	SKIPGE	-2(B)
	SUBI	B,1		;COMPUTE THE HEADER ADDRESS.
	HLRE	A,-1(B)
	MOVMS	A
	IMUL	A,[-3]
	ADDI	B,-2(A)
	HRRZS	B
	JRST	CORREL		;RELEASE IT.

BEND
COMMENT	⊗  bexit & stkuwd  ⊗
DSCR BEXIT
PARM -- XWD #LEVELS-1,LVI ADDRESS IN LPSA
DES -- RELEASES STROAGE FOR BLOCKS -- REPLACES THE OLD ARRREL
SID -- MANGLES ALL REGISTERS
⊗

HERE(BEXIT)
BEGIN BEXIT
BKCNT←5
BKPTR←6
TPTR←7
EN←10	;ALSO USED BY STKUWD
PDA←11	;THIS IS USED BY STKUWD, BUT SOME OF THE LVIDAC ROUTINES MUST SAVE IT
	;SINCE THEY ARE SOMETIMES USED BY STKUWD -- THIS IS CHEAPEST WAY

	PUSH	P,A			;SAVE A
	HLRE	BKCNT,LPSA		;SAVE COUNT
	HRRZ	BKPTR,LPSA		;POINT
	MOVE	TPTR,[POINT 4,EN,3]	;BYTE PTR FOR TYPE
NXTEN:	MOVE	EN,(BKPTR)		;PICK ONE UP
	LDB	A,TPTR			;PICK UP TYPE
	PUSHJ	P,@[ ↑↑LVIDAC:	DRYROT
				RARY	;1
				RARY	;2
				SLFRE	;3 -- SET OR LIST
				LAFRE	;LEAP ARRAY OF SETS OR LISTS
	
				FEVAR	;5 FOR EACH CONTROL VARIABLE
				KLIST	;6  
				CTEXTT	;7 CONTEXT
				CLNUP	;10
				RDREF	;11 RECORD
				RRARY	;12 RECORD ARRAY
				DRYROT	;13
				DRYROT	;14
				DRYROT	;15
				DRYROT	;16
				BKE	;17 END OF BLOCK AREA
				](A)
	AOJA	BKPTR,NXTEN	;GET NEXT

DRYROT: ERR <DRYROT: BEXIT>
	POPJ	P,

RGC <
RRARY:				;RECORD ARRAYS ARENT SPECIAL IF HAVE GC
>;RGC

RARY:	SKIPN   C,@EN
	POPJ	P,
	EXCH	C,(P)		;CLEVER WAY TO FIX THE STACK FOR CALL TO
				;ARYEL
	PUSH	P,C
	SETZM	@EN		;SAY IT IS GONE
	JRST	ARYEL		;MAKE IT THE TRUTH
SLFRE:	SKIPN	A,@EN		;
	POPJ	P,
	SETZM	@EN		;ZERO OUT THE DESCRIPTOR
	PUSH	P,5		;SAVE IT
	PUSH	P,6
	MOVEI	5,0		;FOR RECLAIMER
	PUSHJ	P,RECQQ		;SINCE SET
	POP	P,6
	POP	P,5
	POPJ	P,
CTEXTT: SKIPN	A,@EN		;CONTEXT EMPTY?
	POPJ	P,		;YES
	PUSH	P,EN		;CONTEXT ADDRESS
	PUSHJ	P,ALLFOR	;FORGET EVERYTHING
	POPJ	P,

LAFRE:	SKIPN	A,@EN		;ARRAY PTR
	POPJ	P,		;NOBODY HOME
	PUSH	P,A
	SETZM	@EN
	PUSHJ	P,ARRRCL	;JRL'S MAGICAL SET ARRAY ZAPPER
	EXCH	A,(P)		;CLEVER TRICK AGAIN
	PUSH	P,A		;
	JRST	ARYEL		;GIVE UP THE SPACE
BKE:	SOJGE	BKCNT,GETNXT	;DO WE NEED TO DO MORE?
	MOVE	A,-1(P)
	SUB	P,[XWD 3,3]	;
	JRST	@1(P)		;NO
GETNXT:	MOVEI	BKPTR,@EN	;GET LINK
	SOJGE	BKPTR,CPOPJ	;WILL COMPENSATE FOR AOS
	ERR 	<DRYROT: BEXIT>
FEVAR:	SKIPN	A,@EN
CPOPJ:	POPJ	P,
	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
; NOW CALL LEAP TO RELEASE FOREACH
	MOVEI	5,47		;CHANGED (11-30-72) TO REFLECT NEW INDICES
	PUSHJ	P,LEAP
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,
KLIST:	SKIPN	A,@EN
	POPJ	P,
	ERR	<UNTERMINATED PROCESS DEPENDS ON A BLOCK BEING EXITED 
MAY CONTINUE >,1
	POPJ	P,


CLNUP:	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
	PUSHJ	P,(EN)		;CALL THE PROUCEDURE
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,

REC <
RDREF:	
NORGC <
	SKIPN	A,@EN		;GONE ALREADY
	POPJ	P,
	SOSLE	-1(A)		;REF COUNT LOSES ONE
	JRST	.+3		;DONE
	AOS	-1(A)		;PUT IT BACK SO NEXT GUY CAN DO SAME
	RECUUO	0,@EN		;DEREFERENCE LIKE SO
	SETZM	@EN		;ZERO OUT
	POPJ	P,		;RETURN

RRARY:	SKIPN	A,@EN		;RECORD ARRAY STILL THERE??
	POPJ	P,		;NOPE
	SETZM	@EN		;WE ARE KILLING IT
	PUSH	P,(P)		;RETN ADRS
	MOVEM	A,-1(P)		;FOR EVENTUAL CALL TO ARYEL
	HRLZI	EN,C		;
	HRRI	EN,-1(A)	;EN = POINTER AT NEXT
	HRRZ	C,-1(A)		;C = COUNT
	JUMPE	C,ARYEL		;ALL DONE
	PUSHJ	P,RDREF		;DEREFERENCE ONE
	SOJG	C,.-1		;ITERATE UNTIL DONE
	JRST	ARYEL
>;NORGC
RGC <
	SETZM	@EN		;SO GC DOESN'T FIND IT
	POPJ	P,
>;RGC
>;REC
NOREC <
RRARY:
RDREF:	JRST	DRYROT
>;NOREC


BEND BEXIT

HERE (STKUWD)
BEGIN	STKUWD
DSCR STKUWD
DES THIS PROCEDURE UNWINDS THE STACK TO ESTABLISH A CORRECT DISPLAY AND
	LEXIC LEVEL.
PAR LPSA=XWD CORRECT LL,CORRECT DL
SID MANGLES YOUR ACS (EXCEPT F, P, SP -- WHICH ARE PROPERLY FIXED UP)
⊗

CDLSAV←5
LLFGR←6
SIN←7
EN←10
PDA←11

	MOVE	USER,GOGTAB		
	POP	P,STKURT(USER)		;REMEMBER RETURN ADDRESS
	HRRZM	LPSA,CDLSAV		;
	HLROM	LPSA,LLFGR		;SET UP PARAMETERS FOR USE 
PLOOP:	HLRZ	PDA,1(RF)		;PICK UP PROC DESC ADDRESS
;;#LP# (25 FEB 73)1 OF 1 -- RHT -- MUST CHECK FOR GO TO OUT OF PROCESS
	CAIN	PDA,0			;IS THIS THE BITTER END
	ERR	<GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
;;#LP#
;;#NG# -- RHT ALWAYS ADJUST STACKS BEFORE DO LVI NOW!
	MOVE	SP,2(RF)		;OLD OLD SP
	HLLZ	A,PD.DSW(PDA)		;EXTRA SS DISPL NEED
	HLR	A,A			;BOTH SIDES
	ADD	SP,A			;
	HRRZ	A,PD.DSW(PDA)		;ARITH STK DISPL
	ADDI	A,(RF)			;+RF
	HRRZ	B,P			;WHERE WE ARE NOW
	SUB	B,A			;HOW FAR BACK TO GO
	HRL	B,B			;BOTH SIDES
	SUB	P,B			;TRIMMED BACK
;;#NG# 
	CAMN	PDA,CDLSAV		;IS THIS THE PARENT ???
	HRRZS	LLFGR			;USE THIS AS A FLAG
	HRRZ	SIN,PD.LLW(PDA)		;POINTER AT LVI INFO
NXTEN:	SKIPN	EN,(SIN)		;A ZERO SAYS
	JRST	EOPD			;WE ARE AT END OF LOC VAR INF
TPGET:	LDB	A,[POINT 4,EN,3]	;TYPE FIELD
	CAIN	A,17			;IGNORE END OOF BK ENTRIES
	AOJA	SIN,NXTEN
	JUMPL	LLFGR,DOIT		;IF NOT AT RIGHT DL, ZAP EM ALL
	LDB	B,[POINT =9,EN,=12]	;LL FIELD
	CAMG	B,LLFGR			;IF LEX LEV IS LOW ENOUGH
	AOJA	SIN,NXTEN		;LET HIM LIVE -- VERY INEFFICIENT CODE
DOIT:	PUSHJ	P,@LVIDAC(A)		;CALL APPROPRIATE ROUTINE
	AOJA	SIN,NXTEN
EOPD:	JUMPL	LLFGR,EOPD.1		;RETURN TEST
	MOVE 	USER,GOGTAB		;
	JRST	@STKURT(USER)
EOPD.1:	HRRZ	SIN,PD.DLW(PDA)		;NOW HAVE TO CLEAR OUT SET FORMALS
	HRRZ	B,PD.NPW(PDA)		;#ARITH +1
	MOVE	C,RF			;F REG
	SUBI	C,1(B)			;C← PTR 1 BEFORE 1'ST ARITH PARM
PARLP:	SOJLE	B,ADJSKS		;COUNT DOWN # ARGS
	AOS	C			;POINT AT NEXT
;;#SO# RHT,RFS THIS PIECE OF CODE WAS STILL USING B
	MOVE	EN,(SIN)			;TYPE CODE
;;#NF# RHT 24 JULY 73 THIS PIECE OF CODE WAS STILL USING TBITS
	TLC	EN,SETYPE⊗5		;VALUE SET MUST BE RELEASED
	TLNN	EN,REFB!ITEMB!PROCB	;THESE ARE NOT RELEASED
	TLNE	EN,MSK6BT		;CHECK THE SET CODE
;;#NF#
;;#SO#
	AOJA	SIN,PARLP		;IF NOT VALUE SET, NO PROBLEMS
	MOVEI	EN,(C)			;EN←← PTR TO SET
;; BY JRL 8-31- 72 FOLLOWING INSTRUCTION WAS PUSHJ P,@LVIDAC+4
;;%  % MAKE SET RELEASE SAFE FOR THIS LOOP (MERE PARANOIA)
	PUSH	P,SIN
	PUSH	P,C
	PUSH	P,B
	PUSHJ	P,@LVIDAC+3		;CALL SET RELEASER
	POP	P,B
	POP	P,C
	POP	P,SIN
;;%  %
	AOJA	SIN,PARLP		;GO ON TO NEXT
ADJSKS:	HRRZ	RF,(RF)			;BACK A DYNAMIC LINK
;;#NG# -- USED TO ADJUST STACKS HERE
	JRST	PLOOP			;

BEND STKUWD

COMMENT ⊗ array info & the like ⊗

DSCR INTEGER←ARRINFO(ARRAY,CODE);
CAL SAIL
⊗

HERE (ARRINFO)
BEGIN ARRINFO
	MOVE	A,-2(P)	;ARRAY ADDRESS
	SKIPGE	-2(A)	;STRING ARRAY?
	 SUBI	 A,1		; YES, BACK UP FOR IT
	SKIPGE	TEMP,-1(P)	;CONTROL PARAMETER
	 JRST	 [HLRE A,-1(A) ;WANTS NUMBER OF DIMENSIONS
		   JRST RSINFO]
	JUMPE	TEMP,[HRRZ A,-1(A) ;WANTS TOTAL SIZE
			JRST RSINFO]
; WANTS A BOUND
	ROT	TEMP,-1		;SAVE LOW ORDER BIT AS SIGN
	MOVNI	LPSA,3		;GET DISPLACEMENT INTO ARRAY TABLE
	IMULI	LPSA,(TEMP)
	SKIPGE	TEMP		;WANT UPPER OR LOWER BOUND
	SUBI	LPSA,4
	HRLI	A,LPSA
	MOVE	A,@A		;GET THE REQD BOUND
RSINFO:	
	SUB	P,X33
	JRST	@3(P)
BEND ARRINFO

DSCR ARRBLT(@DEST,@SOURCE,LENGTH);
CAL SAIL
⊗

HERE (ARRBLT) 
BEGIN ARRBLT
;;#PL 12-1-73 RLS  (1 OF 2)  DONT BLT IF COUNT IS LEQ 0
	SOSGE	LPSA,-1(P)		;GET LENGTH, SUBTRACT 1
	  JRST	BLTRET			;LEQ 0, DONT BLT
;;#PL
	HRRZ	TEMP,-3(P)
	HRL	TEMP,-2(P)
	ADDI	LPSA,(TEMP)
	BLT	TEMP,(LPSA)
;;#PL 12-1-73 RLS (2 OF 2)  DONT BLT IF COUNT IS LEQ 0:  LABEL NEXT LINE
BLTRET:	SUB	P,X44
	JRST	@4(P)
BEND  ARRBLT

DSCR ARRTRAN(DEST ARRAY,SOURCE ARRAY);
CAL SAIL
⊗

HERE (ARRTRAN)
BEGIN ARRTRAN
	HRRZ	TEMP,-2(P)		;DEST ARRAY ADDR
	HRRZ	LPSA,-1(P)		;SOURCE ARRAY ADDR
	SKIPL	-2(TEMP)		;STRING ARRAY?
	 JRST	 NSTR			; NO
	SUBI	TEMP,1
	SUBI	LPSA,1

NSTR:	HRL	TEMP,LPSA		;BLT WORD
	HRRZ	LPSA,-1(LPSA)		;SOURCE SIZE
	HRRZ	USER,-1(TEMP)
	CAMLE	LPSA,USER
	 HRRZ	 LPSA,USER
	ADDI	LPSA,-1(TEMP)		;TERMINATION WORD
	BLT	TEMP,(LPSA)
	SUB	P,X33
	JRST	@3(P)
BEND ARRTRAN


DSCR ARRCLR(ARRAY,VAL(0)) 
DES	FILLS UP ARRAY WITH VAL
CAL SAIL
⊗

HERE(ARRCLR)
BEGIN ARRCLR
	MOVE	USER,-1(P)		;VALUE TO PUT
	MOVE	TEMP,-2(P)		;GET ADDRESS OF ARRAY
	SKIPL	-2(TEMP)		;CHECK STRING ARRAY
	JRST	NOSACL
	SUBI	TEMP,1			;A STRING ARRAY STARTS EARLIER
	CAIE	USER,0			;
	ERR	<YOU CANNOT CLEAR STRING ARRAYS TO OTHER THAN NULL>;
NOSACL:	HRLI	LPSA,(TEMP)		;PREPARE FOR BLT
	HRRI	LPSA,1(TEMP)
	MOVEM	USER,(TEMP)
	HRRZ	USER,-1(TEMP)		;GET NUMBER OF WORDS IN ARRAY
;;#TS# CHECK FOR ONE WORD ARRAYS
	SOJLE	USER,DONEIT		;CHECK ONE WORD ARRAYS
	ADDI	TEMP,(USER)		;NUMBER OF WORDS TO MOVE IN BLT
;;#TS# ↑
	BLT	LPSA,(TEMP)		;DO A BLT
DONEIT:	SUB	P,X33
	JRST	@3(P)			;RETURN
BEND ARRCLR


ENDCOM(ARY)

IFE ALWAYS, <
COMPIL(DM1,<RECQQ,ARRRCL,LEAP>,,<DUMMY LEAP BEXIT TARGETS>)
↑↑RECQQ:
↑↑ARRRCL:
↑↑LEAP: 
	ERR <DRYROT-LIBRARY>
ENDCOM(DM1)
COMPIL(DM2,<SPRPDA,RESUME,TERMIN,SPROUT,DADDY,CURSCB,ACF,PLISTE>
					,,<DUMMY PROCESS VARIABLES>)
↑↑SPRPDA:
↑↑RESUME:
↑↑TERMIN:
↑↑SPROUT:
↑↑DADDY:
	ERR <DRYROT-LIBRARY>
↑↑CURSCB ←← 0;
↑↑ACF←←12+3;
↑↑PLISTE ←← 0;
ENDCOM(DM2)
COMPIL(DM3,<ALLFOR>,,<DUMMY BACKTRACKING BEXIT TARGET>)
↑↑ALLFOR:
	ERR <DRYROT-LIBRARY>
ENDCOM(DM3)

COMPIL(DM4,<APPL$Y>,,<DUMMY APPLY PD ENTRY>)
↑↑APPL$Y: 
	.+1
	ERR <DRYROT-LIBRARY>
ENDCOM(DM4)
>;IFE ALWAYS


COMMENT ⊗ the procedure item routines
⊗

COMPIL(PIT,<PITCOP,PITBND,APPLY,PITDTM>,<GINFTB,INFTB,DATM,GDATM,GOGTAB,RECQQ,LEAP>
	,<PROCEDURE ITEM ROUTINES>,<APPL$Y>)

COMMENT ⊗ APPLY$ IS NOT MADE AN ENTRY.  HOWEVER IT IS INTERNALED.  THUS
PIT WILL NOT BE LOADED SIMPLY BECAUSE OF THE EXTERNAL REQUEST IN SAIPRC
FOR APPLY$ ⊗

BEGIN PITS
FLAG←0;
PDA ← 4
NPW ← 5
FPTR←6
FRM←7
APTR←10

GLOB <
GBRK←←6000 
>;GLOB

DSCR PITBND,PITCOP
CAL
	PUSH P,DITM
	PUSH P,XXX
	PUSHJ P,PITBND	<OR PITCOP>

PARM DITM IS ITEM TO BE MADE INTO PROCEDURE ITEM
	FOR PITBND, XXX IS PDA OF PROC TO BE BOUND
	FOR PITCOP, XXX IS PROCEDURE ITEM NUMBER
DES PUTS INTO DITM'S DATUM: XWD STATIC LINK,PDA &SETS DITM'S TYPE TO PITTYP
SID MANGLE TEMP,LPSA,USER,B,C
⊗



HERE (PITBND)
	HRRZ	LPSA,-1(P)		;PICK UP PDA
	HRRZ	TEMP,PD.PPD(LPSA)	;PARENT'S PDA
;;#LM# ! WAS A SKIPE
	SKIPN	PD.PPD(TEMP)		;IF DADDY IS THE GLOBAL MAN (IE
	JRST	PUTDTM			;THE OUTER BLOCK -- INDICATED BY HIS
					;HAVING NO FATHER -- THEN DONT LOOK FOR
					;A STATIC LINK -- YOU WILL USE 0

	SKIPA	USER,RF			;
CTXTLP:	HRRZ	USER,(USER)		;GO UP A LINK
	HLRZ	B,1(USER)		;PDA AT THIS LEVEL.  NOTE WE
	CAME	TEMP,B			;FIRST LOOK AT THIS GUY
	JRST	CTXTLP			;NOT THE ONE
	HRL	LPSA,USER		;NOW LPSA IS SL,,PDA
	JRST	PUTDTM			;GO PUT IN THE DATUM

HERE(PITCOP)
	MOVE	C,-1(P)			;PICK UP ITEM NO INTO B
	PUSHJ	P,PITDGT		;GET DATUM
PUTDTM:	MOVE 	C,-2(P)			;TARGET
	MOVEI	TEMP,PITTYP		;SPECIAL CODE
GLOB <
	CAIL 	C,GBRK			;IS IT GLOBAL???
	JRST	[
		TERPRI	<DON'T BIND PROCEDURES TO GLOBAL ITEMS>
		CAI	C,
		ERR	<ITEM NUMBER>,6
		]
	>;GLOB

	MOVE	USER,GOGTAB
	DPB	TEMP,INFOTAB(USER)	;PUT IN NEW DATUM TYPE
	MOVEM	LPSA,@DATAB(USER)	;SET DATUM
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN

PITDGT:					;PROCEDURE TO GET PIT DATUM
	MOVE	LPSA,GOGTAB
GLOB <
	CAIL	C,GBRK			;
	MOVE	LPSA,GLUSER
>;GLOB
	LDB	B,INFOTAB(LPSA)
	CAIE	B,PITTYP		;IS IT A PROCEDURE ITEM???
	JRST	[ CAI C,
		ERR <NOT A PROCEDURE ITEM >,6]
GLOB <
	CAIL	C,GBRK
	ERR	<DRYROT AT PITDGT>
>;GLOB
	MOVE	LPSA,@DATAB(LPSA)	;FETCH DATUM
	POPJ	P,

DSCR PITDTM
CAL 	PUSH	P,PIT NO
	PUSHJ	P,PITDTM
DES	SETS THE TOP OT THE STACK TO THE DATUM OF THE PROCEDURE ITEM
⊗

HERE(PITDTM)
	MOVE	C,-1(P)			;PICK UP ITEM NO
	PUSHJ	P,PITDGT		;GET ITS DATUM
	MOVEM	LPSA,-1(P)		;SET IT DOWN INTO THE STACK
	POPJ	P,

DSCR APPLY
CAL 
BAIL<
	PUSH	P,location to return string result
	PUSH	P,location to return non-string result	
		the context below will be -1 and is a special flag value,
		not really the static link
>;BAIL
	PUSH	P,[xwd context,pda]
	PUSH	P,ARGLIS
	PUSHJ	P,APPLY
DES  
	APPLY is the interpretive caller. Essentially, it uses the items
in ARGLIS to build a procedure call on the procedure named by the pda.
If context=0, then the procedure is just called in the normal manner. 
If context is not zero, then APPLY will build a MSCP, using this value
as the static link, and will jrst to the instruction after the mscp.

⊗

HERE(APPL$Y)
	APPLY	;A FAKED UP PD SO CAN SPROUT APPLY
		;NOTE HERE THAT FOR UP WILL HAVE TO GO THROUGH 1 MORE 
		;LEVEL OF INDIRECTION

HERE(APPLY)
	MOVE	PDA,-2(P)
BAIL<
	SETZ	TAC2,			;ASSUME NOT BAIL APPLY
	TLC	PDA,-1
	TLCN	PDA,-1			;BAIL APPLY?
	SETO	TAC2,			;YES
>;BAIL
	MOVE	NPW,PD.NPW(PDA)		;THE STACK DISPLACEMENTS
	HRRZ	FPTR,PD.DLW(PDA)	;POINT AT FORMALS
NOGLOB <
	MOVE	USER,GOGTAB		;
>;NOGLOB
BAIL<
	JUMPE	TAC2,NBAP01		;IF NOT BAIL APPLY
	MOVE	APTR,-1(P)		;ARLIST LOCATION-1
	JRST	NXTP
NBAP01:
>;BAIL
	SKIPN	APTR,-1(P)		;ARG LIST
	JUMPN	FPTR,NEACTS		;NULL ACTS,NON NULL FRMS
NXTP:	SOJLE	NPW,ARGSON		;HAD ENOUGH?
	HLRZ	FRM,(FPTR)		;NEXT FORMAL TYPE
BAIL<
	JUMPE	TAC2,NBAP02		;IF NOT BAIL APPLY
	AOS	APTR			;POINT TO NEXT REFITEM DATUM
	SKIPN	A,(APTR)		;SKIP IF NOT END OF LIST
	JRST	NEACTS
	JRST	BAPCHK			;GO CHECK TYPES
NBAP02:
>;BAIL
	HRRZ	APTR,(APTR)		;LOOK AT NEXT ACTUAL
	JUMPE	APTR,NEACTS		;DONT HAVE ONE
	HLRZ	C,(APTR)		;THE ITEM
GLOB <
	MOVE	USER,GOGTAB		;
	CAIL	C,GBRK			;GLOBAL ??
	MOVE	USER,GLUSER		;
>;NOGLOB
	LDB	A,INFOTAB(USER)		;GET TYPE
	CAIE	A,RFITYP		;REF ITEM?
	JRST	[ PRINT <APPLY -- NON REFERENCE ITEM USED IN ACT PARAM LIST>
		JRST	BARG1
		]
	MOVE	A,@DATAB(USER)		;GET THE DATUM
BAIL<
BAPCHK:	
>;BAIL
	TRNE	FRM,ITEMB		;FORMAL AN ITEM?
	JRST 	FITEM			;YES
	TLNE	A,ITEMB			;ACTUAL AN ITEMVAR TYPE THING?
	JRST	BFACT			;LOSE ON CORRESP
	MOVE	B,A			;CHECK 6 BIT TYPE CORRESP
	TLC	B,(FRM)			;
	TLNE	B,MSK6BT		;TEST 6 BIT MASK
	JRST	BFACT			;MAY LATER CONSIDER COERCING
	TRNE	FRM,REFB		;
	JRST	FRMREF			;FORMAL IS A REF
;;#QZ# ! 2-3-74 USED NOT TO BE SHIFTED RHT
	TLC	A,STTYPE⊗5		;STRING ?
	TLNN	A,MSK6BT		;WELL?
	JRST	STVPSH			;YOU BETCHA
	PUSH	P,@A			;PUSH THE VALUE OF THE ARG
	AOJA	FPTR,NXTP		;GO GET NEXT
STVPSH:	PUSH	SP,-1(A)		;PUSH A STRING
	PUSH	SP,(A)			;
	ADD	NPW,[XWD -2,1]		;FIX FOR THE SOJ AT NXTP
	AOJA	FPTR,NXTP
FRMREF:	MOVEI	A,@A			;THE ADDRESS
	PUSH	P,A			;THE REF
	AOJA	FPTR,NXTP		;NEXT
FITEM:	TLNN	A,ITEMB			;IS ACTUAL AN ITEM TOO
	JRST	BFACT			;YOU LOSE!
	MOVE	B,A			;GET ACTUAL BITS
	TLC	B,(FRM)			;6 BIT TYPES
	TRNN	FRM,MSKUNT		;FORMAL HAS 6 BIT TYPE?
	JRST	OK6BT			;NO
;;#QW# 1 OF 2 ALLOW MORE LENIENCY HERE
	TLNN	A,MSKUNT		;DOES ACT HAVE 6 BIT TYPE SPEC
	JRST	AUTITM			;NOPE
;;#QW#
	TLNE	B,MSK6BT		;WIN?
	JRST	BFACT			;NO
OK6BT:	TLNE	B,ARY2B			;THE ARY2 BIT OK?
	JRST	BFACT			;NO
	TLNE	A,BINDB			;BINDING ACTUAL?
	JRST	BNDACT			;YES
	TLNE	A,QUESB			;? ACTUAL?
	JRST	QUEACT			;YES
;;#OL# WAS MAKING WRONG TEST !!
	TRNE	FRM,REFB		;FORMAL REF?
	JRST	FRMREF			;YES
	PUSH	P,@A			;PUSH THE ITEM
	AOJA	FPTR,NXTP		;FETCH NEXT
BNDACT:	TRNN	FRM,QUESB		;FORMAL BETTER BE ?
	JRST 	BFACT
PSHBRF:	MOVEI	A,@A
	TLO	A,20			;TURN ON INDIR BIT
	PUSH	P,A			; @ REF
	AOJA	FPTR,NXTP		; GO DO NEXT
QUEACT:	TRNN	FRM,QUESB		;BETTER BE ?
	JRST	BFACT
	MOVE	B,@A			;GET  THE VALUE NOW
	CAIN	B,UNBND			;HAVE A BINDING?
	JRST	PSHBRF			;NO
	PUSH	P,B			;YES
	AOJA	FPTR,NXTP		;

;;#QW# 1-29-74 RHT (2 OF 2)
AUTITM:					;COME HERE WHEN FORMAL SPEC & ACT UNSPEC
	TLNE	A,ARY2B			;ACT AN ARY2 THING?
	JRST	OK6BT			;YES, PRETEND THAT 6 BIT TYPES ARE OK
	TRNE	FRM,REFB!BINDB		;FORMAL REF OR BIND ?
	JRST	OK6BT			;IF SO, A REGULAR WIN
	SKIPN	C,@A			;GET ULT VALUE TO SEE IF OK
	JRST	OK6BT			;LET ANY THROUGH TOO
	CAIN	C,UNBND			;UNBOUND ? WILL ACT LIKE BIND
	TRNN	FRM,QUESB		;
	SKIPA	USER,GOGTAB		;NOT THIS BAD CASE
	JRST	OK6BT			;WAS UNBND ? IVAR
GLOB <	
	CAIL	C,GBRK
	MOVEI	USER,GLUSER
>;GLOB
	LDB	C,INFOTAB(USER)		;GET ACTUAL ITEM TYPE
	LSH	C,5			;TO LINE THINGS UP FOR THE TRC
	TRC	C,(FRM)			;CHECK 6 BIT TYPE OF THIS ACTUAL VAL ITEM
	TRNN	C,MSK6BT		;SEE IF WIN
	JRST	OK6BT			;WELL, WE HAVE REALLY WON
;ELSE FALL INTO BFACT CODE
;;#QW# 
BFACT:	PRINT	<BAD CORRESPONDENCE BETWEEN ACTUAL & FORMAL PARAMETER TYPE>
BARG1:	JSP	TAC1,PRTARG		;
	JSP	TAC1,PITERR
	JSP	TAC1,PSPFIX		;FIX P & SP
	JRST	CRET			;EXIT FROM IT ALL

PRTARG:	MOVEI	FLAG,1(FPTR)		;FORMAL POINTER
	SUB	FLAG,PD.DLW(PDA)	;ORIGIN
	HRRZ	FLAG,FLAG		;GET THE RH OF IT
	TERPRI
	PRINT	<ARGUMENT NUMBER >
	DECPNT	FLAG
	TERPRI
	JRST	(TAC1)			;RETURN
PSPFIX:	MOVE	A,PD.NPW(PDA)
	SUB	A,NPW			;
	SUBI	P,(A)			;FIXUP RIGHT
	HRLZ	FLAG,A			;
	ADD	P,FLAG			;FIX LEFT
	MOVS	A,A
	SUBI	SP,(A)			;
	HRLZ	FLAG,A
	ADD	SP,FLAG			;FIX SP
	MOVEI	A,0
	JRST	(TAC1)			;RETURN

NEACTS: TERPRI
	PRINT	<APPLY--NOT ENOUGH ACTUAL PARAMETERS SUPPLIED >
	JRST	BARG1


ARGSON:
BAIL<
	JUMPN	TAC2,CAL1		;SKIP SPECIAL CONTEXT FOR BAIL
>;BAIL
	TLNN	PDA,-1			;WERE WE GIVEN A CONTEXT
	JRST 	CAL1			;NO
	PUSH	P,[CRET]		;PUSH	RETURN ADDRESS
	PUSH	P,RF
	HRRZ	A,PD.PPD(PDA)		;PARENTS PDA
	MOVS	B,PDA			;PDA,,STATIC LINK
	HLRZ	FRM,1(B)			;PDA OF DADDY???
	CAME	FRM,A			;????
	JRST	[
		PRINT	<CONTEXT WRONG OR CLOBBERED IN INTERP CALL>
		JSP	TAC1,PITERR
		JSP	TAC1,PSPFIX
		JRST	CRET
		]
	PUSH	P,B			;STATIC LINK
	PUSH	P,SP			;
	HLRZ	A,PD.PPD(PDA)		;WORD AFTER MKSEMT
	JRST	(A)			;GO THERE
CAL1:	HRRZ	A,PD.(PDA)		;ENTRY ADDRESS
	PUSHJ	P,(A)			;CALL IT
CRET:	MOVE	PDA,-2(P)		;HERE ON RETURN
BAIL<
	SETZ	TAC2,			;ASSUME NOT BAIL APPLY
	TLC	PDA,-1
	TLCN	PDA,-1			;BAIL APPLY?
	SETO	TAC2,			;YES
>;BAIL
	MOVE	FRM,PD.PDB(PDA)		;PROC type
BAIL<
	JUMPE	TAC2,NBAP03		;IF NOT BAIL APPLY
	TLC	FRM,STTYPE⊗5		;SIMPLE STRING?
	TLNE	FRM,MSK6BT!ITEMB	;WELL?
	JRST	BAPRNS			;NO
	MOVE	A,-4(P)			;YES. ADDRESS OF STRING DESCR
	POP	SP,(A)			;FIRST WORD
	POP	SP,-1(A)		;SECOND WORD
	JRST	.+2
BAPRNS:	MOVEM	A,@-3(P)		;RETURN NON-STRING RESULT
	SUB	P,[XWD 5,5]
	JRST	@5(P)			;RETURN
NBAP03:
>;BAIL
;;#QU# ! type forgot the lsh 5 RHT  1-28-74
	TLC	FRM,STTYPE⊗5		;SIMPLE STRING?
	TLNN	FRM,MSK6BT!ITEMB	;WELL?
	SUB	SP,[XWD 2,2]		;POP	SP STACK
;;%BH%
	SKIPN	B,-1(P)			;GET THE LIST
	JRST	TMIDON			;NO LIST
TMIKIL:	
	HRRZ	B,(B)			;STEP THE LIST
	JUMPE	B,TMIDON		;A ZERO MARKS THE END
	HLRZ	C,(B)			;GET ITEM NUMBER
	SKIPL	@DATM			;AT THIS POINT, KNOW IS REFITEM
	JRST	TMIKIL			; THE SIGN BIT IS TMPB (GEQ 0 MEANS PERM)
					;IF GET HERE C IS A TEMP ITEM
	PUSH	P,B			;SAVE LIST PTR
	PUSH	P,C			;THE ITEM NUMBER
	MOVEI	5,43			;DELETE CODE
	PUSHJ	P,LEAP			;UGH! WHAT A TERRIBLE WAY TO DO THINGS
	POP	P,B
	JRST	TMIKIL			;CONTINUE
TMIDON:
;;%BH%
	SKIPGE	B,-1(P)			;GET THE LIST 
	PUSHJ	P,RECBQQ		;ARGL WAS TEMP, RELEASE IT
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN


PITERR:	TERPRI 
	PRINT <PROCEDURE IS >
	TERPRI
	PUSHJ	P,PRPID
	ERR	<IF YOU CONTINUE, THE PROCEDURE WILL NOT BE CALLED >,1
	JRST	(TAC1)

PRPID:	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	HRRZ	B,PD.ID1(PDA)
	MOVE	A,PD.ID2(PDA)
	SOJL	B,.+4
	ILDB	C,A
	TTCALL	1,C
	JRST	.-3
	POP	P,C
	POP	P,B
	POP	P,A
	POPJ	P,

;;#OP# MAKE SURE A GETS SAVED
RECBQQ:	EXCH 	A,B
	PUSH	P,B
	PUSHJ	P,RECQQ
	POP	P,A
	POPJ	P,
;;#OP#

BEND PITS
ENDCOM(PIT)
BEND GOGOL
INTERNAL ..PAT.
..PAT.:
PATCH:	BLOCK	50